home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / ra2fls.zip / RA2FLS.PAS < prev    next >
Pascal/Delphi Source File  |  1991-11-26  |  13KB  |  486 lines
  1. uses
  2.      dos, crt,
  3.      totFAST, totLINK, totLIST, totKEY, totSTR, totWIN,
  4.      totIO1, totIO2,   totINPUT, totMISC;
  5.  
  6. {$I struct.110}
  7.  
  8. type
  9.    arearecord       = record
  10.                         name           :string[30];
  11.                         tag            :word;
  12.                         filepath       :string[40];
  13.                       end;
  14.  
  15.    afmrecord        = record
  16.                         arearec        :array[1..200] of arearecord;
  17.                         bbsname        :string[40];
  18.                         daysnew        :longint;
  19.                         newfile        :string[40];
  20.                         outfile        :string[40];
  21.                         headerfile     :string[40];
  22.                         flsconfig      :string[40];
  23.                       end;
  24.  
  25. const
  26.    prog                         = ' RA2FLS ';
  27.    ver                          = '1.0 ';
  28.    afmconfigfile                = 'RA2FLS.CFG';
  29.  
  30.  
  31. var
  32.    f                            :file;
  33.    raconfigfile                 :string;
  34.    rafilesfile                  :string;
  35.    flsconfigfile                :string;
  36.    afmrec                       :^afmrecord;
  37.    changed                      :boolean;
  38.    manager                      :formOBJ;
  39.    mainwin                      :winOBJ;
  40.  
  41.    io_outfname,io_headerfname   :lateralIOOBJ;
  42.    io_bbsname,io_newfiles       :lateralIOOBJ;
  43.    io_flsconfig                 :lateralIOOBJ;
  44.    io_daysnew                   :intIOOBJ;
  45.    io_keys                      :controlKeysIOOBJ;
  46.    io_ok,io_esc                 :stripIOOBJ;
  47.    io_new                       :stripIOOBJ;
  48.    io_result                    :taction;
  49.    allfinished                  :boolean;
  50.  
  51.  
  52. { -------------------------------------------------------------------------- }
  53. procedure msg(str  :string);
  54.  
  55. begin
  56.   screen.writeplain(1,25,str);
  57. end;
  58.  
  59. { -------------------------------------------------------------------------- }
  60. procedure errorexit( msg  :string);
  61.  
  62. begin
  63.   writeln(^G+msg);
  64.   halt(1);
  65. end;
  66.  
  67. { -------------------------------------------------------------------------- }
  68. procedure fixpaths;
  69.  
  70. var  env               :string;
  71.  
  72. begin
  73.   env := getenv('RA');
  74.     if env = '' then                      { read RA enviroment variable }
  75.        errorexit('Unable to read RA enviroment variable.');
  76.  
  77.   raconfigfile := slasheddirectory(env)+raconfigfile;      { add path to config file }
  78.   rafilesfile := slasheddirectory(env)+rafilesfile;
  79.  
  80.   if not exist(raconfigfile) then
  81.      errorexit('Unable to open RA config file <'+raconfigfile+'>');
  82.  
  83.   if not exist(rafilesfile) then
  84.      errorexit('Unable to open RA files file <'+rafilesfile+'>');
  85. end;
  86.  
  87. { -------------------------------------------------------------------------- }
  88. procedure parseraconfig;
  89.  
  90. var  numread             :integer;
  91.      f                   :file;
  92.      buf                 :^configrecord;
  93.  
  94. begin
  95.   if maxavail < sizeof(configrecord)
  96.       then errorexit('Memory allocation error.');
  97.   new(buf);                               { malloc RAM }
  98.   assign(f,raconfigfile);
  99.   reset(f,1);
  100.   with buf^ do
  101.     begin
  102.       blockread(f,buf^,sizeof(buf^),numread);
  103.       afmrec^.bbsname := systemname+' - '+inttostr(address[0].zone)+':'+
  104.                inttostr(address[0].net)+'/'+inttostr(address[0].node)+'.'+
  105.                inttostr(address[0].point);
  106.     end;
  107.   dispose(buf);
  108.  close(f);
  109. end;
  110.  
  111.  
  112. { -------------------------------------------------------------------------- }
  113. procedure savecfg;
  114.  
  115. var  numwritten           :integer;
  116.      f                    :file;
  117.      tf                   :text;
  118.      l                    :byte;
  119.  
  120. begin
  121.   assign(f,afmconfigfile);
  122.   rewrite(f,1);
  123.    blockwrite(f,afmrec^,sizeof(afmrec^),numwritten);
  124.   close(f);
  125.   msg('Saving config file    ... ');
  126.  
  127.  with afmrec^ do
  128.  begin
  129.  assign(tf,flsconfig);
  130.  rewrite(tf);
  131.    writeln(tf,bbsname);
  132.    writeln(tf,daysnew);
  133.    writeln(tf,newfile);
  134.    writeln(tf,outfile);
  135.    writeln(tf,headerfile);
  136.       for l := 1 to 200 do
  137.            if (arearec[l].tag <> 0) then
  138.              writeln(tf,arearec[l].filepath,' <',arearec[l].tag,
  139.              '> ',arearec[l].name);
  140.  close(tf);
  141.  end;
  142. end;
  143.  
  144.  
  145. { -------------------------------------------------------------------------- }
  146. procedure initnewcfg;
  147.  
  148. var  numwritten           :integer;
  149.      l                    :word;
  150.      f                    :file;
  151.  
  152. begin
  153.   parseraconfig;
  154.   assign(f,afmconfigfile);
  155.   rewrite(f,1);
  156.   with afmrec^ do
  157.    begin
  158.    for l := 1 to 200 do
  159.      begin
  160.        arearec[l].name := '';
  161.        arearec[l].tag  := 0;
  162.        arearec[l].filepath := '';
  163.      end;
  164.        daysnew := 31;
  165.        outfile := '635-534.LST';
  166.        headerfile := 'FILES.TOP';
  167.        newfile := 'NEWFILE.ASC';
  168.        flsconfig := 'FILELIST.CFG';
  169.     end;
  170.   blockwrite(f,afmrec^,sizeof(afmrec^),numwritten);
  171.   close(f);
  172.   msg('Making new config file    ... ');
  173. end;
  174.  
  175. { -------------------------------------------------------------------------- }
  176. procedure opencfg;
  177.  
  178. var  numread           :integer;
  179.      f                 :file;
  180.  
  181. begin
  182.   if not exist(afmconfigfile) then
  183.   begin
  184.     initnewcfg;
  185.     assign(f,afmconfigfile);   { create new file }
  186.     reset(f,1);
  187.     blockread(f,afmrec^,sizeof(afmrec^),numread);
  188.     close(f);
  189.     if numread <> sizeof(afmrec^) then
  190.        errorexit('Data file corrupted <'+afmconfigfile+'>');
  191.      msg('Reading config file    ... ');
  192.   end
  193.   else
  194.   begin    { open existing file }
  195.     assign(f,afmconfigfile);
  196.     reset(f,1);
  197.     blockread(f,afmrec^,sizeof(afmrec^),numread);
  198.     close(f);
  199.     if numread <> sizeof(afmrec^) then
  200.        errorexit('Data file corrupted <'+afmconfigfile+'>');
  201.      msg('Reading config file    ... ');
  202.   end;
  203. end;
  204.  
  205. { -------------------------------------------------------------------------- }
  206. procedure updaterec;
  207.  
  208. begin
  209.    with afmrec^ do
  210.    begin
  211.        bbsname := io_bbsname.getvalue;
  212.        newfile  := io_newfiles.getvalue;
  213.        outfile := io_outfname.getvalue;
  214.        headerfile := io_headerfname.getvalue;
  215.        daysnew := io_daysnew.getvalue;
  216.        flsconfig := io_flsconfig.getvalue;
  217.    end;
  218. end;
  219.  
  220. { -------------------------------------------------------------------------- }
  221. procedure finishup;
  222.  
  223. begin
  224.  dispose(afmrec);
  225. end;
  226.  
  227. { -------------------------------------------------------------------------- }
  228. procedure parsefilesfile(var itemlist  :strdllobj);
  229.  
  230. var  numread           :integer;
  231.      f                 :file;
  232.      buf               :^filesrecord;
  233.      count             :integer;
  234.      scount            :string[5];
  235.  
  236. begin
  237.   count := 1;
  238.   new(buf);
  239.   assign(f,rafilesfile);
  240.   reset(f,1);
  241.   repeat
  242.      blockread(f,buf^,sizeof(buf^),numread);
  243.      str(count:3,scount);
  244.      if (itemlist.add(scount+' - '+buf^.name) <> 0) then
  245.        errorexit('Memory allocation error.');
  246.      afmrec^.arearec[count].filepath := slasheddirectory(buf^.filepath);
  247.      inc(count);
  248.   until eof(f);
  249.  dispose(buf);
  250. end;
  251.  
  252. { -------------------------------------------------------------------------- }
  253. {$F+}
  254. procedure selectfiles;
  255.  
  256. var   l                      :longint;
  257.       itemlist               :strdllobj;
  258.       listwin                :listlinkobj;
  259.  
  260. begin
  261.    itemlist.init;
  262.    parsefilesfile(itemlist);
  263.    with listwin do
  264.    begin
  265.       init;
  266.       assignlist(itemlist);
  267.       setcolwidth(39);
  268.       setcolors(lightcyan,blue+cyan shl 4,black+cyan shl 4);
  269.       win^.settitle(' File areas ');
  270.       win^.setsize(10,4,50,23,1);
  271.       win^.setboundary(1,1,80,23);
  272.       win^.setcolors(blue+cyan shl 4,blue+cyan shl 4,
  273.                      black+cyan shl 4,yellow + cyan shl 4);
  274.       settagging(true);
  275.       for l := 1 to 200 do
  276.            if (afmrec^.arearec[l].tag <> 0) then
  277.              setstatus(l,0,true);
  278.       go;
  279.       remove;
  280.       if lastkey = kF10 then
  281.       begin
  282.       for l := 1 to itemlist.totalnodes  do
  283.          if getstatus(l,0) then
  284.             begin
  285.                 afmrec^.arearec[l].tag := l;
  286.                 afmrec^.arearec[l].name := getstring(l,7,36);
  287.             end
  288.             else
  289.             begin
  290.                 afmrec^.arearec[l].tag := 0;
  291.                 afmrec^.arearec[l].name := '';
  292.             end;
  293.       savecfg;
  294.       end;
  295.       done;
  296.    end;
  297.    itemList.done;
  298. end;
  299.  
  300. {$F-}
  301.  
  302. { -------------------------------------------------------------------------- }
  303. {$F+}
  304. function cmdparser(var K:word; var X,Y:byte; var ID:word):tAction;
  305.  
  306. begin
  307.    case K of
  308.        kAltF     : selectfiles;
  309.    end;
  310.  
  311. end;
  312. {$F-}
  313.  
  314. { -------------------------------------------------------------------------- }
  315. procedure initvars;
  316.  
  317. begin
  318.    with io_bbsname do
  319.    begin
  320.       init(18,3,30,40);
  321.       setlabel('BBS name');
  322.       setvalue(afmrec^.bbsname);
  323.       setmessage(1,25,'The name of your BBS system');
  324.    end;
  325.    with io_headerfname do
  326.    begin
  327.       init(18,5,30,40);
  328.       setlabel('Header filename');
  329.       setvalue(afmrec^.headerfile);
  330.       setmessage(1,25,'The name of the <pre header> file');
  331.    end;
  332.    with io_outfname do
  333.    begin
  334.       init(18,7,30,40);
  335.       setlabel('Out filename');
  336.       setvalue(afmrec^.outfile);
  337.       setmessage(1,25,'The name of the <allfiles> file to be created');
  338.    end;
  339.    with io_newfiles do
  340.    begin
  341.       init(18,9,30,40);
  342.       setlabel('New files file');
  343.       setvalue(afmrec^.newfile);
  344.       setmessage(1,25,'The name of the <newfiles> file to be created');
  345.    end;
  346.    with io_daysnew do
  347.    begin
  348.       init(18,11,3);
  349.       setvalue(afmrec^.daysnew);
  350.       setlabel('Days new');
  351.       setmessage(1,25,'The number of days it takes to say that a file is new');
  352.    end;
  353.    with io_flsconfig do
  354.    begin
  355.       init(18,13,30,40);
  356.       setlabel('Config file');
  357.       setvalue(afmrec^.flsconfig);
  358.       setmessage(1,25,'The FILELIST configuration file');
  359.    end;
  360.    with io_ok do
  361.    begin
  362.         init(18,16,'  OK   ',Finished);
  363.         setmessage(1,25,'Save configuration and Exit.');
  364.    end;
  365.    with io_new do
  366.    begin
  367.         init(18,18,' Init  ',stop1);
  368.         setmessage(1,25,'Initialise a new configuration');
  369.    end;
  370.    with io_esc do
  371.    begin
  372.         init(18,20,' ESC   ',Escaped);
  373.         setmessage(1,25,'Abandon any changes and Exit.');
  374.    end;
  375.    io_keys.Init;
  376. end;
  377.  
  378. { -------------------------------------------------------------------------- }
  379. procedure disposevars;
  380.  
  381. begin
  382.    io_outfname.done;
  383.    io_headerfname.done;
  384.    io_bbsname.done;
  385.    io_newfiles.done;
  386.    io_daysnew.done;
  387.    io_flsconfig.done;
  388.    io_ok.done;
  389.    io_esc.done;
  390.    io_new.done;
  391.    io_keys.done;
  392. end;
  393.  
  394.  
  395. { -------------------------------------------------------------------------- }
  396. procedure mainprocess;
  397.  
  398. begin
  399.    repeat;
  400.    initvars;
  401.    with mainwin do
  402.    begin
  403.       init;
  404.       setsize(1,1,51,23,1);
  405.       settitle(Prog+' '+Ver+' ... press Alt-F for files');
  406.       setclose(false);
  407.       setremove(true);
  408.       setcolors(cyan,white,white,lightblue);
  409.       draw;
  410.    end;
  411.    screen.clear(lightgray,chr(176));
  412.    with manager do
  413.    begin
  414.       init;
  415.       additem(io_keys);
  416.       additem(io_bbsname);
  417.       additem(io_headerfname);
  418.       additem(io_outfname);
  419.       additem(io_newfiles);
  420.       additem(io_daysnew);
  421.       additem(io_flsconfig);
  422.       additem(io_ok);
  423.       additem(io_new);
  424.       additem(io_esc);
  425.       setcharhook(cmdparser);
  426.       mouse.show;
  427.       io_result := go;
  428.       mouse.hide;
  429.       mainwin.done;
  430.       case io_result of
  431.        finished    : begin
  432.                        allfinished := true;
  433.                        updaterec;
  434.                        savecfg;
  435.                        writeln('Saved changes');
  436.                      end;
  437.       stop1        : begin
  438.                       initnewcfg;
  439.                      end;
  440.       else
  441.                      begin
  442.                        writeln('Abandoned changes');
  443.                        allfinished := true;
  444.                      end;
  445.       end;
  446.       disposevars;
  447.       done;
  448.    end;
  449.   if changed then savecfg;
  450.   until allfinished;
  451. end;
  452.  
  453. { -------------------------------------------------------------------------- }
  454. procedure initialise;
  455.  
  456. begin
  457.  raconfigfile := 'CONFIG.RA';
  458.  rafilesfile  := 'FILES.RA';
  459.  allfinished := false;
  460.  changed := false;
  461.  new(afmrec);
  462.    if afmrec = nil then
  463.      errorexit('Memory allocation error.');
  464.  with iotot^ do
  465.    begin
  466.      setcolmsg(white);
  467.      setcollabel(lightgray,yellow, yellow, yellow);
  468.      setcolfield(white,cyan, lightgray, lightgray);
  469.      setcolbutton(lightcyan,yellow, yellow, yellow);
  470.      setcolgroup(blue + cyan shl 4,yellow,white,yellow);
  471.    end;
  472.  fixpaths;
  473.  opencfg;
  474. end;
  475.  
  476. { -------------------------------------------------------------------------- }
  477.  
  478. begin
  479.  clrscr;
  480.  initialise;
  481.  mainprocess;
  482.  finishup;
  483. end.
  484.  
  485.  
  486.